Toggle between layers to view COVID 19 rates from NYC Health and observed mask usage by the New York Times.

Click on an area for more info.

NYC Health (Dates)

Using data from NYC Health, these layers map out city-wide COVID 19 Rates per 100,000 People in each ZCTA. This map includes weekly rates from July 13 to August 10, 2020. Mouseover of ZCTA shows area name, borough, ZCTA, and case rate as designated by NYC Health.

New York Times Mask Observations (NYT Obs)

Using data from the New York Times article “Are New Yorkers Wearing Masks?”, this layer maps out observed mask usage rates by the Times’ reporters between July 27 to July 30, 2020. The additional NYT Obs layers shows observed mask usage rates based on perceived gender. The ZCTAs where the intersections of the Times reporters were used to map out observed mask usage rates and to compare NYC Health data with. Mouseover of the ZCTA shows area name, borough, and intersection of observation as reported by the Times. ZCTAs were found by me.

Link to article: https://www.nytimes.com/2020/08/20/nyregion/nyc-face-masks.html 

## No trace type specified:
##   Based on info supplied, a 'scatter' trace seems appropriate.
##   Read more about this trace type -> https://plot.ly/r/reference/#scatter
## No trace type specified:
##   Based on info supplied, a 'bar' trace seems appropriate.
##   Read more about this trace type -> https://plot.ly/r/reference/#bar

Analysis

nyc.avg.caserate <- nyc.covid19.mask %>% 
  select("zip", "date","area", "COVID_CASE_RATE") %>% 
  dplyr::group_by(zip) %>% 
  dplyr::arrange(zip, date) %>% 
  mutate(rate = (COVID_CASE_RATE - lag(COVID_CASE_RATE))/lag(COVID_CASE_RATE)) %>% 
  summarise(avg_rate = mean(rate, na.rm = TRUE))
## `summarise()` ungrouping output (override with `.groups` argument)
nyc.avg.rate.mask <- left_join(nyt.data, nyc.avg.caserate, by ="zip") %>% 
  mutate(obs_mask = 1 - obs_mask)
plot_ly(nyc.avg.rate.mask,
        x = ~area,
        y = ~obs_mask,
        type = 'scatter',
        mode = 'markers',
        name = 'Mask Rate',
        visible = T) %>% 
  add_trace(nyc.avg.rate.mask, y = ~avg_rate, name = 'Avg. Change Rate', visible = T) %>% 
  layout(
    title = 'Observed Mask Rates & COVID 19 Positive Rates by Area',
    showlegend = TRUE,
    yaxis = list(title = "% of Masks Observed/COVID 19 Positive Rate",tickformat = "%"),
    xaxis = list(title = "Area"),
    hovermode = 'compare'
)
avg_rate.mask_model <- lm(formula = avg_rate ~ obs_mask, data = nyc.avg.rate.mask)

summary(avg_rate.mask_model)
## 
## Call:
## lm(formula = avg_rate ~ obs_mask, data = nyc.avg.rate.mask)
## 
## Residuals:
##        Min         1Q     Median         3Q        Max 
## -0.0034172 -0.0009060 -0.0000578  0.0005096  0.0037204 
## 
## Coefficients:
##               Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  0.0121353  0.0009391  12.922 2.11e-08 ***
## obs_mask    -0.0094030  0.0030206  -3.113  0.00897 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.002089 on 12 degrees of freedom
## Multiple R-squared:  0.4468, Adjusted R-squared:  0.4007 
## F-statistic:  9.69 on 1 and 12 DF,  p-value: 0.008972